home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tm / tm-bbdb.el.z / tm-bbdb.el
Encoding:
Text File  |  1998-05-21  |  9.8 KB  |  303 lines
  1. ;;; tm-bbdb.el --- tm shared module for BBDB
  2.  
  3. ;; Copyright (C) 1995,1996 Shuhei KOBAYASHI
  4. ;; Copyright (C) 1996 Artur Pioro
  5.  
  6. ;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
  7. ;;         Artur Pioro <artur@flugor.if.uj.edu.pl>
  8. ;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
  9. ;; Version: $Id: tm-bbdb.el,v 7.27 1996/12/10 14:24:23 morioka Exp $
  10. ;; Keywords: mail, news, MIME, multimedia, multilingual, BBDB
  11.  
  12. ;; This file is part of tm (Tools for MIME).
  13.  
  14. ;; This program is free software; you can redistribute it and/or
  15. ;; modify it under the terms of the GNU General Public License as
  16. ;; published by the Free Software Foundation; either version 2, or (at
  17. ;; your option) any later version.
  18.  
  19. ;; This program is distributed in the hope that it will be useful, but
  20. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22. ;; General Public License for more details.
  23.  
  24. ;; You should have received a copy of the GNU General Public License
  25. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27. ;; Boston, MA 02111-1307, USA.
  28.  
  29. ;;; Code:
  30.  
  31. (require 'std11)
  32. (require 'tm-ew-d)
  33. (require 'tm-view)
  34. (if (module-installed-p 'bbdb-com)
  35.     (require 'bbdb-com)
  36.   (eval-when-compile
  37.     ;; imported from bbdb-1.51
  38.     (defmacro bbdb-pop-up-elided-display ()
  39.       '(if (boundp 'bbdb-pop-up-elided-display)
  40.        bbdb-pop-up-elided-display
  41.      bbdb-elided-display))
  42.     (defmacro bbdb-user-mail-names ()
  43.       "Returns a regexp matching the address of the logged-in user"
  44.       '(or bbdb-user-mail-names
  45.        (setq bbdb-user-mail-names
  46.          (concat "\\b" (regexp-quote (user-login-name)) "\\b"))))
  47.     ))
  48.  
  49.  
  50. ;;; @ User Variables
  51. ;;;
  52.  
  53. (defvar tm-bbdb/use-mail-extr t
  54.   "*If non-nil, `mail-extract-address-components' is used.
  55. Otherwise `tm-bbdb/extract-address-components' overrides it.")
  56.  
  57. (defvar tm-bbdb/auto-create-p nil
  58.   "*If t, create new BBDB records automatically.
  59. If function, then it is called with no arguments to decide whether an
  60. entry should be automatically creaded.
  61.  
  62. tm-bbdb uses this variable instead of `bbdb/mail-auto-create-p' or
  63. `bbdb/news-auto-create-p' unless other tm-MUA overrides it.")
  64.  
  65. (defvar tm-bbdb/delete-empty-window nil
  66.   "*If non-nil, delete empty BBDB window.
  67. All bbdb-MUAs but bbdb-gnus display BBDB window even if it is empty.
  68. If you prefer behavior of bbdb-gnus, set this variable to t.
  69.  
  70. For framepop users: If empty, `framepop-banish' is used instead.")
  71.  
  72. ;;; @ mail-extr
  73. ;;;
  74.  
  75. (defun tm-bbdb/extract-address-components (str)
  76.   (let* ((ret     (std11-extract-address-components str))
  77.          (phrase  (car ret))
  78.          (address (car (cdr ret)))
  79.          (methods tm-bbdb/canonicalize-full-name-methods))
  80.     (while (and phrase methods)
  81.       (setq phrase  (funcall (car methods) phrase)
  82.             methods (cdr methods)))
  83.     (if (string= address "") (setq address nil))
  84.     (if (string= phrase "") (setq phrase nil))
  85.     (list phrase address)
  86.     ))
  87.  
  88. (or tm-bbdb/use-mail-extr
  89.     (progn
  90.       (require 'mail-extr) ; for `what-domain'
  91.       (or (fboundp 'tm:mail-extract-address-components)
  92.           (fset 'tm:mail-extract-address-components
  93.                 (symbol-function 'mail-extract-address-components)))
  94.       (fset 'mail-extract-address-components
  95.         (symbol-function 'tm-bbdb/extract-address-components))
  96.       ))
  97.  
  98.  
  99. ;;; @ bbdb-extract-field-value
  100. ;;;
  101.  
  102. (or (fboundp 'tm:bbdb-extract-field-value)
  103.     (progn
  104.       ;; (require 'bbdb-hooks) ; not provided.
  105.       ;; (or (fboundp 'bbdb-extract-field-value) ; defined as autoload
  106.       (or (fboundp 'bbdb-header-start)
  107.           (load "bbdb-hooks"))
  108.       (fset 'tm:bbdb-extract-field-value
  109.             (symbol-function 'bbdb-extract-field-value))
  110.       (defun bbdb-extract-field-value (field)
  111.         (let ((value (tm:bbdb-extract-field-value field)))
  112.           (and value
  113.                (mime-eword/decode-string value))))
  114.       ))
  115.  
  116.  
  117. ;;; @ full-name canonicalization methods
  118. ;;;
  119.  
  120. (defun tm-bbdb/canonicalize-spaces (str)
  121.   (let (dest)
  122.     (while (string-match "\\s +" str)
  123.       (setq dest (cons (substring str 0 (match-beginning 0)) dest))
  124.       (setq str (substring str (match-end 0)))
  125.       )
  126.     (or (string= str "")
  127.         (setq dest (cons str dest)))
  128.     (setq dest (nreverse dest))
  129.     (mapconcat 'identity dest " ")
  130.     ))
  131.  
  132. (defun tm-bbdb/canonicalize-dots (str)
  133.   (let (dest)
  134.     (while (string-match "\\." str)
  135.       (setq dest (cons (substring str 0 (match-end 0)) dest))
  136.       (setq str (substring str (match-end 0)))
  137.       )
  138.     (or (string= str "")
  139.         (setq dest (cons str dest)))
  140.     (setq dest (nreverse dest))
  141.     (mapconcat 'identity dest " ")
  142.     ))
  143.  
  144. (defvar tm-bbdb/canonicalize-full-name-methods
  145.   '(mime-eword/decode-string
  146.     tm-bbdb/canonicalize-dots
  147.     tm-bbdb/canonicalize-spaces))
  148.  
  149.  
  150. ;;; @ BBDB functions for mime/viewer-mode
  151. ;;;
  152.  
  153. (defun tm-bbdb/update-record (&optional offer-to-create)
  154.   "Return the record corresponding to the current MIME previewing message.
  155. Creating or modifying it as necessary. A record will be created if
  156. tm-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and
  157. the user confirms the creation."
  158.   (save-excursion
  159.     (if (and mime::article/preview-buffer
  160.              (get-buffer mime::article/preview-buffer))
  161.         (set-buffer mime::article/preview-buffer))
  162.     (if bbdb-use-pop-up
  163.         (tm-bbdb/pop-up-bbdb-buffer offer-to-create)
  164.       (let* ((from (std11-field-body "From"))
  165.              (addr (if from
  166.                (car (cdr (mail-extract-address-components from))))))
  167.         (if (or (null from)
  168.                 (null addr)
  169.                 (string-match (bbdb-user-mail-names) addr))
  170.             (setq from (or (std11-field-body "To") from))
  171.       )
  172.         (if from
  173.             (bbdb-annotate-message-sender
  174.              from t
  175.              (or (bbdb-invoke-hook-for-value tm-bbdb/auto-create-p)
  176.                  offer-to-create)
  177.              offer-to-create))
  178.         ))))
  179.  
  180. (defun tm-bbdb/annotate-sender (string)
  181.   "Add a line to the end of the Notes field of the BBDB record
  182. corresponding to the sender of this message."
  183.   (interactive
  184.    (list (if bbdb-readonly-p
  185.              (error "The Insidious Big Brother Database is read-only.")
  186.            (read-string "Comments: "))))
  187.   (bbdb-annotate-notes (tm-bbdb/update-record t) string))
  188.  
  189. (defun tm-bbdb/edit-notes (&optional arg)
  190.   "Edit the notes field or (with a prefix arg) a user-defined field
  191. of the BBDB record corresponding to the sender of this message."
  192.   (interactive "P")
  193.   (let ((record (or (tm-bbdb/update-record t)
  194.                     (error ""))))
  195.     (bbdb-display-records (list record))
  196.     (if arg
  197.     (bbdb-record-edit-property record nil t)
  198.       (bbdb-record-edit-notes record t))))
  199.  
  200. (defun tm-bbdb/show-sender ()
  201.   "Display the contents of the BBDB for the sender of this message.
  202. This buffer will be in bbdb-mode, with associated keybindings."
  203.   (interactive)
  204.   (let ((record (tm-bbdb/update-record t)))
  205.     (if record
  206.     (bbdb-display-records (list record))
  207.     (error "unperson"))))
  208.  
  209. (defun tm-bbdb/pop-up-bbdb-buffer (&optional offer-to-create)
  210.   "Make the *BBDB* buffer be displayed along with the MIME preview window(s),
  211. displaying the record corresponding to the sender of the current message."
  212.   (let ((framepop (eq temp-buffer-show-function 'framepop-display-buffer)))
  213.     (or framepop
  214.         (bbdb-pop-up-bbdb-buffer
  215.          (function
  216.           (lambda (w)
  217.             (let ((b (current-buffer)))
  218.               (set-buffer (window-buffer w))
  219.               (prog1 (eq major-mode 'mime/viewer-mode)
  220.                 (set-buffer b)))))))
  221.     (let ((bbdb-gag-messages t)
  222.           (bbdb-use-pop-up nil)
  223.           (bbdb-electric-p nil))
  224.       (let ((record (tm-bbdb/update-record offer-to-create))
  225.             (bbdb-elided-display (bbdb-pop-up-elided-display))
  226.             (b (current-buffer)))
  227.         (if framepop
  228.             (if record
  229.                 (bbdb-display-records (list record))
  230.               (framepop-banish))
  231.           (bbdb-display-records (if record (list record) nil))
  232.           (if (and (null record)
  233.                    tm-bbdb/delete-empty-window)
  234.               (delete-windows-on (get-buffer "*BBDB*"))))
  235.         (set-buffer b)
  236.         record))))
  237.  
  238. (defun tm-bbdb/define-keys ()
  239.   (let ((mime/viewer-mode-map (current-local-map)))
  240.     (define-key mime/viewer-mode-map ";" 'tm-bbdb/edit-notes)
  241.     (define-key mime/viewer-mode-map ":" 'tm-bbdb/show-sender)
  242.     ))
  243.  
  244. (add-hook 'mime-viewer/define-keymap-hook 'tm-bbdb/define-keys)
  245.  
  246.  
  247. ;;; @ for signature.el
  248. ;;;
  249.  
  250. (defun signature/get-bbdb-sigtype (addr)
  251.   "Extract sigtype information from BBDB."
  252.   (let ((record (bbdb-search-simple nil addr)))
  253.     (and record
  254.          (bbdb-record-getprop record 'sigtype))
  255.     ))
  256.  
  257. (defun signature/set-bbdb-sigtype (sigtype addr)
  258.   "Add sigtype information to BBDB."
  259.   (let* ((bbdb-notice-hook nil)
  260.          (record (bbdb-annotate-message-sender
  261.                   addr t
  262.                   (bbdb-invoke-hook-for-value
  263.                    bbdb/mail-auto-create-p)
  264.                   t)))
  265.     (if record
  266.         (progn
  267.           (bbdb-record-putprop record 'sigtype sigtype)
  268.           (bbdb-change-record record nil))
  269.       )))
  270.  
  271. (defun signature/get-sigtype-from-bbdb (&optional verbose)
  272.   (let* ((to (std11-field-body "To"))
  273.          (addr (and to
  274.                     (car (cdr (mail-extract-address-components to)))))
  275.          (sigtype (signature/get-bbdb-sigtype addr))
  276.          return
  277.          )
  278.     (if addr
  279.         (if verbose
  280.             (progn
  281.               (setq return (signature/get-sigtype-interactively sigtype))
  282.               (if (and (not (string-equal return sigtype))
  283.                        (y-or-n-p
  284.                         (format "Register \"%s\" for <%s>? " return addr))
  285.                        )
  286.                   (signature/set-bbdb-sigtype return addr)
  287.                 )
  288.               return)
  289.           (or sigtype
  290.               (signature/get-signature-file-name))
  291.           ))
  292.     ))
  293.  
  294.  
  295. ;;; @ end
  296. ;;;
  297.  
  298. (provide 'tm-bbdb)
  299.  
  300. (run-hooks 'tm-bbdb-load-hook)
  301.  
  302. ;;; end of tm-bbdb.el
  303.